;;; Automatic test generator

(require (lib "set.ss" "galore")
         (lib "galore-units.ss" "galore")
         (lib "unitsig.ss")
         (lib "list.ss"))

(define types
  '(
    ;(singleton    : elm         -> set)
    
    ;;(set          : elm ...     -> set)
    ;(set          : elm     -> set)
    
    ;(size         : set         -> integer)
    ;(elements     : set         -> (list elm))
    
    (set-union        : set set     -> set)
    (set-intersection : set set     -> set)
    (set-difference   : set set     -> set)
    
    ;(empty?       : set         -> boolean)
    
    ;(insert1      : elm set     -> set)
    
    ;(member?      : elm set     -> boolean)
    ;;(member       : elm set     -> (union elm #f))
    
    ;(subset?      : set set     -> boolean)
    ;(equal?       : set set     -> boolean)
    
    ;(insert       : set elm ... -> set)
    (set-insert       : set elm -> set)
    
    ; (remove       : set elm ... -> set)
    (set-remove       : set elm -> set)
    ;(remove1      : elm set     -> set)
    ))

(define (operations)
  (map car types))

(define (operation-member operation)
  (ormap (lambda (type) 
           (if (eq? (first type) operation) 
               type 
               #f))
         types))

; (operation-type 'insert) ==> (set elm ... -> set)
(define (operation-type operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-type "no type associated with ~a" operation))
    (rest (rest type))))

; (before-arrow '(a b -> c))  ==> (a b)
(define (before-arrow type)
  (when (not (member '-> type)) (error 'before-arrow "no arrow in type: ~a" type))
  (do ((type   type (cdr type))
       (before '()  (cons (car type) before)))
    ((eq? (first type) '->)
     (reverse! before))))

; (after-arrow '(a b -> c))  ==>  c
(define (after-arrow type)
  (when (not (member '-> type)) (error 'after-arrow "no arrow in type: ~a" type))
  (first (rest (member '-> type))))

; (operation-result-type 'insert)  ==>  set
(define (operation-result-type operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-result-type "unknown operation: ~a" operation))
    (after-arrow type)))

; (operation-argument-types 'insert) ==>  (set elm)
(define (operation-argument-types operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-argument-types "unknown operation: ~a" operation))
    (rest (rest (before-arrow type)))))

; (operations/result-type 'boolean)  ==>  (empty? member? subset? equal?)
(define (operations/result-type type)
  (filter (lambda (op)
            (equal? (operation-result-type op) type))
          (operations)))

(define (build-base-level-expr type)
  (case type
    [(set) `(set-insert-all empty '(,(random 10) ,(random 10) ,(random 10)))]
    [(elm) (random 10)]
    [else  (error 'build-base-level-expr "no base level exprs known for ~a" type)]))


(define (random-element-of l)
  (list-ref l (random (length l))))


(define (build-expr type level)
  (define (build-sub-expr type) (build-expr type (- level 1)))
  (cond
    [(or (= level 0)
         (empty? (operations/result-type type)))
     (build-base-level-expr type)]
    [else         
     (let* ((operation (random-element-of (operations/result-type type)))
            (arg-exprs (map build-sub-expr (operation-argument-types operation))))
       `(,operation ,@arg-exprs))]))


(define (test-expr expr units order@)
  (define (test-unit u@)
    (let ((n (make-namespace)))
      (parameterize ([current-namespace n])
        (namespace-set-variable-value! 'mergesort mergesort)
        (namespace-set-variable-value! 'empty (make-set u@ order@))
        (namespace-set-variable-value! 'set-union set-union)
        (namespace-set-variable-value! 'set-intersection set-intersection)
        (namespace-set-variable-value! 'set-difference set-difference)
        (namespace-set-variable-value! 'set-insert set-insert)
        (namespace-set-variable-value! 'set-insert-all set-insert-all)
        (namespace-set-variable-value! 'set-remove set-remove)
        (namespace-set-variable-value! 'set-elements set-elements))
      (eval expr n)))
  
  (printf "~a~n" expr)
  (let ((results (map test-unit units)))
    (cond 
      [(not (andmap (lambda (r) (equal? (first results) r))
                    (rest results)))
       (error "FAILED:\n"
              expr "\n" results)]
      [else (printf "~a~n" results)])))



(define collision-integers@
  (unit/sig ordered^
    (import)
    (define (hash a) (- a (modulo a 3)))
    (define elm=   =)
    (define (elm<  a b) (< (hash a) (hash b)))
    (define (elm<= a b) (or (= a b) (elm< a b)))))

(define (test cnt units order)
  (do ((i 0 (+ i 1)))
    ((= i cnt) (void))
    (test-expr `(mergesort (set-elements ,(build-expr 'set (random 8))) <) units order)))

(define collision-tolerant
  (list 
   ordered-list-set@ 
   unbalanced-search-tree-set@ 
   red-black-tree-set@ ))

(define not-collision-tolerant (list randomized-binary-search-tree-set@
                                     weight-balanced-tree-set@))

(test 200 (append collision-tolerant not-collision-tolerant) numbers@)
(test 1000 collision-tolerant collision-integers@)



